Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/GAUGES/DBMETER/DBM.PAS

Pascal/Delphi Source File | 1996-09-09 | 14KB | 473 lines

unit dbm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,extctrls;

type Tdbmeterstyle = (dsVertical,dsHorizontal);
type tdbmeterdirection = (ddRightDown,ddLeftUp);

type
  Tdbmeter = class(tgraphiccontrol)
  private
    { Private-Deklarationen }
    Fbevelstyle : Tpanelbevel;
    Fbevelwidth : byte;

    fgreens,fyellows,freds : integer;
    fgreenmax,fyellowmax,fredmax : integer;

    fcolors : array [1..3,false..true] of Tcolor;

    fshowjustone : boolean;
    fsepwidth    : integer;
    fsepcolor    : Tcolor;
    fstyle       : tdbmeterstyle;
    fdirection   : tdbmeterdirection;
    fposition    : integer;
    fbmp         : tbitmap;

    procedure setbevelstyle(val : Tpanelbevel);
    procedure setbevelwidth(val : byte);

    procedure setgreencolor(val : tcolor);
    procedure setgreenmax(val : integer);
    procedure setgreens(val : integer);
    procedure setgreenback(val : tcolor);

    procedure setyellowcolor(val : tcolor);
    procedure setyellowmax(val : integer);
    procedure setyellows(val : integer);
    procedure setyellowback(val : tcolor);

    procedure setredcolor(val : tcolor);
    procedure setredmax(val : integer);
    procedure setreds(val : integer);
    procedure setredback(val : tcolor);

    procedure setshowjustone(val : boolean);
    procedure setsepwidth(val : integer);
    procedure setsepcolor(val : tcolor);
    procedure setstyle(val : Tdbmeterstyle);
    procedure setdirection(val : Tdbmeterdirection);
    procedure setposition(val : integer);
  protected
    { Protected-Deklarationen }
    procedure paint;override;
    function kompx(x:integer):integer;
    function kompy(y:integer):integer;
    function getlpos(val:integer):integer;
  public
    { Public-Deklarationen }
    constructor create(aowner : Tcomponent);override;
    destructor destroy ; override;
  published
    { Published-Deklarationen }
    property DragCursor;
    property DragMode;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Visible;

    property BevelStyle : TpanelBevel read fbevelstyle write setbevelstyle;
    property BevelWidth : byte read fbevelwidth write setbevelwidth;

    property GreenColor : Tcolor read fcolors[1,true] write setgreencolor;
    property Greens     : integer read fgreens write setgreens;
    property GreenMax   : integer read fgreenmax write setgreenmax;
    property GreenBack  : Tcolor read fcolors[1,false] write setgreenback;

    property YellowColor : Tcolor read fcolors[2,true] write setYellowcolor;
    property Yellows     : integer read fYellows write setYellows;
    property YellowMax   : integer read fYellowmax write setYellowmax;
    property YellowBack  : Tcolor read fcolors[2,false] write setYellowback;

    property RedColor : Tcolor read fcolors[3,true] write setRedcolor;
    property Reds     : integer read fReds write setReds;
    property RedMax   : integer read fRedmax write setRedmax;
    property RedBack  : Tcolor read fcolors[3,false] write setRedback;

    property ShowJustOne : boolean read fshowjustone write setshowjustone;
    property SepWidth    : integer read fsepwidth write setsepwidth;
    property SepColor    : Tcolor read fsepcolor write setsepcolor;
    property Style       : tdbmeterstyle read fstyle write setstyle;
    property Direction   : tdbmeterdirection read fdirection write setdirection;
    property Position    : integer read fposition write setposition;
end;

procedure Register;

implementation

constructor Tdbmeter.create;
begin
     inherited;
     width              := 80;
     height             := 17;
     fbevelstyle        := bvlowered;
     fbevelwidth        := 1;
     fshowjustone       := false;
     fgreens            := 3;
     fcolors[1,true]    := cllime;
     fcolors[2,true]    := clyellow;
     fcolors[3,true]    := clred;
     fcolors[1,false]   := clgray;
     fcolors[2,false]   := clgray;
     fcolors[3,false]   := clgray;
     fyellows           := 2;
     freds              := 1;
     fgreenmax          := 50;
     fyellowmax         := 25;
     fredmax            := 25;
     fsepwidth          := 1;
     fsepcolor          := clsilver;
     fstyle             := dshorizontal;
     fdirection         := ddrightdown;
     fposition          := 0;
     fbmp := tbitmap.create;
end;

destructor tdbmeter.destroy;
begin
     fbmp.free;
     inherited;
end;

function Tdbmeter.kompx(x:integer):integer;
begin
     result := (width - x)-1;
end;
function tdbmeter.kompy(y:integer):integer;
begin
     result := (height - y)-1;
end;

procedure Tdbmeter.setbevelwidth(val : byte);
begin
     if val <> fbevelwidth then begin
        if val = 0 then val := 1;
        if (val > (height div 3)) or (val > (width div 3)) then val := 1;
        fbevelwidth := val;
        paint;
     end;
end;

procedure Tdbmeter.setbevelstyle(val : TPanelbevel);
begin
     if val <> fbevelstyle then begin
        fbevelstyle := val;
        paint;
     end;
end;

procedure Tdbmeter.setgreencolor(val : tcolor);
begin
     if val <> fcolors[1,true] then begin
        fcolors[1,true] := val;
        paint;
     end;
end;
procedure Tdbmeter.setgreenmax(val : integer);
begin
     if val <> fgreenmax then begin
        fgreenmax := val;
        paint;
     end;
end;
procedure Tdbmeter.setgreens(val : integer);
begin
     if val <> fgreens then begin
        fgreens := val;
        paint;
     end;
end;
procedure Tdbmeter.setgreenback(val : tcolor);
begin
     if val <> fcolors[1,false] then begin
        fcolors[1,false] := val;
        paint;
     end;
end;

procedure Tdbmeter.setyellowcolor(val : tcolor);
begin
     if val <> fcolors[2,true] then begin
        fcolors[2,true] := val;
        paint;
     end;
end;
procedure Tdbmeter.setyellowmax(val : integer);
begin
     if val <> fyellowmax then begin
        fyellowmax := val;
        paint;
     end;
end;
procedure Tdbmeter.setyellows(val : integer);
begin
     if val <> fyellows then begin
        fyellows := val;
        paint;
     end;
end;
procedure Tdbmeter.setyellowback(val : tcolor);
begin
     if val <> fcolors[2,false] then begin
        fcolors[2,false] := val;
        paint;
     end;
end;

procedure Tdbmeter.setredcolor(val : tcolor);
begin
     if val <> fcolors[3,true] then begin
        fcolors[3,true] := val;
        paint;
     end;
end;
procedure Tdbmeter.setredmax(val : integer);
begin
     if val <> fredmax then begin
        fredmax := val;
        paint;
     end;
end;
procedure Tdbmeter.setreds(val : integer);
begin
     if val <> freds then begin
        freds := val;
        paint;
     end;
end;
procedure Tdbmeter.setredback(val : tcolor);
begin
     if val <> fcolors[3,false] then begin
        fcolors[3,false] := val;
        paint;
     end;
end;

procedure Tdbmeter.setshowjustone(val : boolean);
begin
     if val <> fshowjustone then begin
        fshowjustone := val;
        paint;
     end;
end;
procedure Tdbmeter.setsepwidth(val : integer);
begin
     if val <> fsepwidth then begin
        fsepwidth := val;
        paint;
     end;
end;
procedure Tdbmeter.setsepcolor(val : tcolor);
begin
     if val <> fsepcolor then begin
        fsepcolor := val;
        paint;
     end;
end;
procedure Tdbmeter.setstyle(val : Tdbmeterstyle);
begin
     if val <> fstyle then begin
        fstyle := val;
        paint;
     end;
end;
procedure Tdbmeter.setdirection(val : Tdbmeterdirection);
begin
     if val <> fdirection then begin
        fdirection := val;
        paint;
     end;
end;
procedure Tdbmeter.setposition(val : integer);
begin
     if val <> fposition then begin
        fposition := val;
        paint;
     end;
end;

function tdbmeter.getlpos(val:integer):integer;
var num : integer;
var ye,gr : integer;
begin
     ye := fyellowmax;
     if yellows = 0 then ye := 0;
     gr := fgreenmax;
     if greens = 0 then gr := 0;
     result := 0;
     if fposition >= (fredmax+gr+ye) then begin
        result := val;
        exit;
     end;
     if fposition > (ye+gr) then begin
        // rote position berechnen
        if reds = 0 then begin
           result := val;
           exit;
        end;
        num := fposition-ye-gr;
        result := round((freds / fredmax) * num)+fgreens+fyellows;
        if result = fgreens+fyellows then result := result+1;
        exit;
     end;
     if fposition > (gr) then begin
        // gelbe position berechnen
        if yellows = 0 then begin
           result := val;
           exit;
        end;
        num := fposition-gr;
        result := round((fyellows / ye) * num)+fgreens;
        if result = fgreens then result := result+1;
        exit;
     end;
     // grⁿne position berechnen
     if gr = 0 then begin
        result := 0;
        exit;
     end;
     result := round((fgreens / gr)* fposition);
end;
procedure Tdbmeter.paint;
var bw : byte;
    tcbottom,tctop : tcolor;
    lp : integer;
    anz : integer;
    breite,hoehe : integer;
    num : integer;
    akt : boolean;
    farbe : byte;
    x0,y0,x1,y1 : integer;
    x2,y2,x3,y3 :integer;
begin
     fbmp.width := width;
     fbmp.height := height;
     with fbmp.canvas do begin
          pen.color := fsepcolor;
          pen.width := 0;
          pen.style := pssolid;
          brush.color := fsepcolor;
          brush.style := bssolid;
          rectangle(0,0,width,height);
     end;
     //anzahl der KΣstchen berechnen
     anz := fgreens+freds+fyellows;
     if anz > 0 then begin
        // breite berechnen
        breite := width div anz;
        hoehe  := height;
        if fstyle = dsvertical then begin
           breite := height div anz;
           hoehe  := width;
        end;
        if breite > fsepwidth then begin
           // berechnen, welches element das letzte ist
           num := getlpos(anz);
           if num = 0 then if fposition <> 0 then num := 1;
           // Farbe berechnen
           fbmp.canvas.pen.width := 0;
           fbmp.canvas.pen.style := pssolid;
           fbmp.canvas.brush.style := bssolid;
           for anz := 1 to anz do begin
               akt := true;
               if anz < num then if fshowjustone then akt := false;
               if anz > num then akt := false;
               farbe := 1;
               if anz > greens+yellows then farbe := 3
               else if anz > greens then farbe := 2;
               fbmp.canvas.brush.color := fcolors[farbe,akt];
               fbmp.canvas.pen.color   := fcolors[farbe,akt];
               // positionen berechnen
               case fstyle of
                    dshorizontal:begin
                                      x0 := (anz-1)*breite;
                                      x1 := anz*breite;
                                      y0 := 0;
                                      y1 := hoehe-1;
                                      // Strich
                                      x2 := anz*breite-fsepwidth;
                                      x3 := x2+fsepwidth+1;
                                      y2 := 0;
                                      y3 := hoehe-1;
                                      if fdirection = ddleftup then begin
                                         x0 := kompx(x0);
                                         x1 := kompx(x1);
                                         x2 := kompx(x2);
                                         x3 := kompx(x3);
                                      end;
                                 end;
               dsvertical: begin
                         y0 := (anz-1)*breite;
                         y1 := anz*breite;
                         x0 := 0;
                         x1 := hoehe-1;
                         // Strich
                         y2 := anz*breite-fsepwidth;
                         y3 := y2+fsepwidth+1;
                         x2 := 0;
                         x3 := hoehe-1;
                         if fdirection = ddleftup then begin
                            y0 := kompy(y0);
                            y1 := kompy(y1);
                            y2 := kompy(y2);
                            y3 := kompy(y3);
                         end;
                         end;
               end;
               // Rechteck ausgeben
               fbmp.canvas.rectangle(x0,y0,x1,y1);
               if sepwidth > 0 then begin
                  fbmp.canvas.brush.color := fsepcolor;
                  fbmp.canvas.pen.color := fsepcolor;
                  fbmp.canvas.rectangle(x2,y2,x3,y3);
               end;
           end;
        end;
     end;

     tcbottom := clwhite;
     tctop := clgray;
     bw := fbevelwidth;
     if fbevelstyle = bvnone then bw := 0;
     if (bw > (height div 3)) or (bw > (width div 3)) then bw := 1;
     if bw > 0 then begin
        if fbevelstyle = bvraised then begin
           tcbottom := clgray;
           tctop := clwhite;
        end;
        with fbmp.canvas do begin
             pen.color := tcbottom;
             // unten rechts;
             for lp := 0 to bw-1 do begin
                 moveto(kompx(width),kompy(lp));
                 lineto(kompx(lp),kompy(lp));
                 lineto(kompx(lp),kompy(height));
             end;
             pen.color := tctop;
             // obenlinks;
             for lp := 0 to bw-1 do begin
                 moveto(width,lp);
                 lineto(lp,lp);
                 lineto(lp,height-bw);
             end;
        end;
     end;
     canvas.draw(0,0,fbmp);
end;

procedure Register;
begin
  RegisterComponents('Samples', [Tdbmeter]);
end;

end.